(in-package :lilu-mcclim-apropos)

(defclass iapropos-application-frame (clim:standard-application-frame)
  ((iapropos :initarg :iapropos)
   (selected-values :initform nil)
   (single-selection-p :initform t)
   (option-panes :initform nil)
   (matched-objects-pane :initform nil)
   (matched-object-packages-pane :initform nil)
   (selected-objects-pane :initform nil)
   (matched-object-presentation-type :initarg :presentation-type)
   (matched-object-name :initarg :object-name)))


(defmethod initialize-instance :after ((frame iapropos-application-frame) &key &allow-other-keys)
  (setf (clim:command-enabled 'com-edit-select-all frame) nil)
  (setf (clim:command-enabled 'com-edit-select-none frame) nil))

(defun iapropos-application-initialize (frame)
  (declare (ignore frame))
  #+nil(iapropos-frame-reset-options frame))

(defmethod clim:frame-standard-input ((frame iapropos-application-frame))
  (with-slots (option-panes iapropos) frame
    (loop for (opt pane) on option-panes by #'cddr
          do
             (when (eql (search-option-type (iapropos-option iapropos opt)) :regex)
               (return (car (clim:sheet-children pane)))))))



(defgeneric iapropos-frame-refresh-metched-objects-pane (frame)
  (:method ((frame iapropos-application-frame))
    (with-slots (matched-objects-pane matched-object-packages-pane) frame
      (clim:redisplay-frame-pane clim:*application-frame*
                                 matched-objects-pane
                                 :force-p t)
      (when matched-object-packages-pane
        (clim:redisplay-frame-pane clim:*application-frame*
                                   matched-object-packages-pane
                                   :force-p t)))))

(defgeneric iapropos-frame-refresh-selected-objects-pane (frame)
  (:method ((frame iapropos-application-frame))
    (with-slots (selected-objects-pane) frame
      (clim:redisplay-frame-pane clim:*application-frame*
                                 selected-objects-pane
                                 :force-p t))))

(defgeneric iapropos-frame-reset-options (frame)
  (:method ((frame iapropos-application-frame))
    (with-slots (iapropos) frame
      (iapropos-reset-option-values iapropos)
      (iapropos-frame-reset-option-panes frame))))

(defgeneric iapropos-frame-reset-option-panes (frame)
  (:method ((frame iapropos-application-frame))
    (with-slots (option-panes iapropos) frame
      (loop for (opt pane) on option-panes by #'cddr
            do
               (iapropos-frame-set-option-value frame pane (iapropos-option-value iapropos opt))))))

(defun iapropos-frame-redisplay-pane (pane-name)
  (anaphora:awhen (clim:find-pane-named clim:*application-frame* pane-name)
    (clim:redisplay-frame-pane clim:*application-frame* anaphora:it :force-p t)))


;;;
;;; make panes
;;;

(defun string-to-keyword (str)
  (if (string= str "nil")
      nil
      (intern (string-upcase str) :keyword)))

(defun keyword-to-string (key)
  (if (eql key nil)
      ""
      (string-downcase (string key))))

;; selection type
(defgeneric iapropos-frame-update-seleciont-type (frame selected-value))

(defun make-iapropos-frame-selection-type-pane (&key (orientation :horizontal))
  (let* ((choices (loop for item in '("single" "multiple")
                        collect (clim:make-pane 'clim:toggle-button
                                                :label item
                                                :indicator-type :one-of)))
         (selection (find "single" choices :key #'clim:gadget-label :test 'string=)))
    (clim:make-pane 'clim:radio-box
                    :orientation orientation
                    :active t
                    :value-changed-callback #'(lambda (this-gadget selected-gadget)
                                                (declare (ignore this-gadget))
                                                (iapropos-frame-update-seleciont-type
                                                 clim:*application-frame*
                                                 (string-to-keyword (clim:gadget-label selected-gadget))))
                    :choices choices
                    :current-selection selection)))

(defmethod iapropos-frame-update-seleciont-type ((frame iapropos-application-frame) selected-value)
  (with-slots (single-selection-p selected-values) frame
    (setf single-selection-p
          (eql selected-value :single))
    (if single-selection-p
        (progn
          (setf selected-values (when selected-values (list (car selected-values))))
          (iapropos-frame-refresh-selected-objects-pane frame)
          (iapropos-frame-refresh-metched-objects-pane frame)
          (setf (clim:command-enabled 'com-edit-select-all frame) nil)
          (setf (clim:command-enabled 'com-edit-select-none frame) nil))
        (progn
          (setf (clim:command-enabled 'com-edit-select-all frame) t)
          (setf (clim:command-enabled 'com-edit-select-none frame) t)))))

;; option value
(defgeneric iapropos-frame-set-option-value (frame pane value)
  (:method ((frame iapropos-application-frame) (pane clim:radio-box-pane) value)
    (let ((selection (keyword-to-string value)))
      (loop for child in (clim:sheet-children pane)
            when (and
                  (typep child 'clim:toggle-button)
                  (equal (clim:gadget-label child) selection))
              do
                 (setf (clim:radio-box-current-selection pane)
                       child))))
  (:method ((frame iapropos-application-frame) (pane clim:text-field-pane) value)
    (let ((selection (keyword-to-string value)))
      (setf (clim:gadget-value pane) selection)))
  (:method ((frame iapropos-application-frame) (pane clim:option-pane) value)
    (setf (clim:gadget-value pane) value)))

(defgeneric iapropos-frame-update-option-value (frame option selected-value))

(defun make-iapropos-frame-option-value-pane (option-name orientation)
  (flet ((make-radio-box-from-items (items default cb orientation)
           (let* ((choices (loop for item in items
                                 collect (clim:make-pane 'clim:toggle-button :label item :indicator-type :one-of)))
                  (selection (find default choices :key #'clim:gadget-label :test 'string=)))
             (clim:make-pane 'clim:radio-box
                             :orientation orientation
                             :active t
                             :choices choices
                             :current-selection selection
                             :value-changed-callback cb))))
    (with-slots (iapropos option-panes) clim:*application-frame*
      (let ((option (iapropos-option iapropos option-name)))
        (let ((option-values (search-option-type option))
              (default-value (search-option-default-value option)))
          (unless (eql (car option-values) 'member)
            (error "expected member type (~A) for option ~A" (car option) option-name))
          (setf option-values (cdr option-values))
          (let ((inst
                  (make-radio-box-from-items
                   (mapcar #'keyword-to-string option-values)
                   (keyword-to-string default-value)
                   #'(lambda (this-gadget selected-gadget)
                       (declare (ignore this-gadget))
                       (iapropos-frame-update-option-value clim:*application-frame* option-name
                                                           (string-to-keyword (clim:gadget-label selected-gadget))))
                   orientation)))
            (setf (getf option-panes option-name) inst)
            (clim:make-pane 'clim:label-pane :label (string-downcase (string option-name))
                                             :contents (list inst))))))))

(defun make-iapropos-frame-option-regex-pane (option-name)
  (with-slots (option-panes) clim:*application-frame*
    (let ((inst (clim:make-pane 'clim:text-field
                                :value-changed-callback #'(lambda (gadget value)
                                                            (declare (ignore gadget))
                                                            (iapropos-frame-update-option-value
                                                             clim:*application-frame* option-name
                                                             value)))))
      (setf (getf option-panes option-name) inst)
      #+nil(clim:make-pane 'clim:label-pane :label (string-downcase (string option-name))
                                            :contents (list inst))
      inst)))

(defmethod iapropos-frame-update-option-value ((frame iapropos-application-frame) option selected-value)
  (with-slots (iapropos selected-values) frame
    (setf (iapropos-option-value iapropos option) selected-value)
    (setf selected-values
          (intersection selected-values (iapropos-matched-objects iapropos))))
  (iapropos-frame-refresh-selected-objects-pane frame)
  (iapropos-frame-refresh-metched-objects-pane frame))

(defun make-iapropos-frame-option-pane-from-items (option-name items)
  (with-slots (option-panes) clim:*application-frame*
    (let ((inst (clim:make-pane 'clim:option-pane
                  :value nil
                  :active nil
                  :items items
                  :name-key #'car
                  :value-key #'cdr
                  :value-changed-callback #'(lambda (this-gadget selected-value)
                                              (declare (ignore this-gadget))
                                              (iapropos-frame-update-option-value
                                               clim:*application-frame*
                                               option-name selected-value)))))
      (setf (getf option-panes option-name) inst)
      (clim:make-pane 'clim:label-pane :label (string-downcase (string option-name))
                                       :contents (list inst)))))

;; selected/matched panes

(defun ipropos-frame-print-matched-objects (frame pane matching-systems result-overflow-p
                                            name selected-values
                                            matched-object-presentation-type
                                            &key (presentation-view clim:+textual-view+))
  (declare (ignore frame))
  (flet ((take (n l)
           (subseq l 0 (if (< (length l) n)
                           (if (> n (1- (length l)))
                               (length l)
                               (1- (length l)))
                           n))))
    (let* ((systems-to-print (take 100 matching-systems)))
      (%print-heading-text (format nil "~A (~A/~A~A)"
                                   name
                                   (length systems-to-print)
                                   (length matching-systems)
                                   (if result-overflow-p "+" ""))
                           pane)
      (if (null matching-systems)
          (progn
            (fresh-line pane)
            (clim:stream-increment-cursor-position pane 5 0)
            (princ "; no results" pane))
          (progn
            (clim:with-output-recording-options (pane :record t :draw nil)
              (dolist (sys systems-to-print)
                (fresh-line pane)
                (clim:stream-increment-cursor-position pane 10 0)
                (clim:with-drawing-options (pane :ink
                                                 (if (member sys selected-values)
                                                     clim:+blue+
                                                     clim:+black+))
                  (clim:present sys matched-object-presentation-type :view presentation-view :stream pane))))
            (clim:stream-replay pane))
          ))))

(defgeneric ipropos-frame-matched-objects-display (frame pane &key presentation-view)
  (:method ((frame iapropos-application-frame) pane &key (presentation-view clim:+textual-view+))
    (with-slots (iapropos selected-values matched-object-presentation-type matched-object-name) frame
      (ipropos-frame-print-matched-objects frame pane
                                           (iapropos-matched-objects iapropos)
                                           (iapropos-result-overflow-p iapropos)
                                           matched-object-name selected-values
                                           matched-object-presentation-type
                                           :presentation-view presentation-view))))

(defvar *ignored-properties* nil)

(defgeneric ipropos-frame-selected-objects-display (frame pane)
  (:method ((frame iapropos-application-frame) pane)
    (with-slots (iapropos selected-values matched-object-presentation-type matched-object-name) frame
      (let ((missing nil))
        (flet ((print-system (object)
                 (let ((*print-escape* t))
                   (fresh-line pane)
                   (loop for (name val) on (iapropos-describe-object iapropos object) by #'cddr
                         do
                            (unless (member name *ignored-properties*)
                              (if (listp val)
                                  (cond
                                    ((null val)
                                      (%print-property pane name val))
                                    ((eql (car val) :file)
                                     (%print-text pane (format nil "~A: " name))
                                     (clim:with-drawing-options (pane :ink clim:+blueviolet+)
                                       (if (consp (cdr val))
                                           (clim:present (cdr val)
                                                         'source-location
                                                         :stream pane :view clim:+textual-view+)
                                           (clim:present (cons (cdr val) 0)
                                                         'source-location
                                                         :stream pane :view clim:+textual-view+))))
                                    ((eql (car val) :object)
                                     (%print-text pane (format nil "~A: " name))
                                     (clim:with-drawing-options (pane :ink clim:+blueviolet+)
                                       (clim:present (cdr val) 'inspect-object
                                                     :stream pane :view clim:+textual-view+)))
                                    (t
                                     (%print-property pane name val)))
                                  (progn
                                    (if (eql val :missing)
                                        (setf missing (push name missing))
                                        (%print-property pane name val)))))))))
          (if (null selected-values)
              (%print-heading-text (format nil "Empty selection") pane)
              (progn
                (%print-sub-heading-text (format nil "Selected ~A" matched-object-name) pane)
                (fresh-line pane)
                (dolist (v selected-values)
                  (clim:stream-increment-cursor-position pane 10 0)
                  (clim:present v matched-object-presentation-type :stream pane))
                (dolist (v selected-values)
                  (%print-text pane (format nil "---------------------------------"))
                  (print-system v)
                  (when missing
                    (%print-property pane "MISSING" missing 0 t))
                  (setf missing nil)
                  ))))))))

(defgeneric ipropos-frame-matched-object-packages-display (frame pane)
  (:method ((frame iapropos-application-frame) pane)
    (with-slots (iapropos) frame
      (multiple-value-bind (matched-packages result-overflow-p)
          (iapropos-matched-object-packages iapropos)
        (ipropos-frame-print-matched-objects frame pane
                                             matched-packages
                                             result-overflow-p
                                             "Package" nil 'matched-object-package)))))

(defun make-ipropos-frame-matched-objects-pane ()
  (with-slots (matched-objects-pane) clim:*application-frame*
    (multiple-value-bind (pane inst)
        (clim:make-clim-application-pane
         :incremental-redisplay nil
         :display-function #'ipropos-frame-matched-objects-display
         :display-time t
         :scroll-bars :vertical
         :end-of-line-action :allow
         :end-of-page-action :allow
         :min-width 250)
      (setf matched-objects-pane inst)
      pane)))

(defun make-ipropos-frame-matched-object-packages-pane ()
  (with-slots (matched-object-packages-pane) clim:*application-frame*
    (multiple-value-bind (pane inst)
        (clim:make-clim-application-pane
         :incremental-redisplay nil
         :display-function #'ipropos-frame-matched-object-packages-display
         :display-time t
         :scroll-bars :vertical
         :end-of-line-action :allow
         :end-of-page-action :allow
         :min-width 250)
      (setf matched-object-packages-pane inst)
      pane)))

(defun make-ipropos-frame-selected-objects-pane ()
  (with-slots (selected-objects-pane) clim:*application-frame*
    (multiple-value-bind (pane inst)
        (clim:make-clim-application-pane
                 :incremental-redisplay t
                 :display-function #'ipropos-frame-selected-objects-display
                 ;;'%system-navigator-render-output
                 :scroll-bars :vertical
                 :end-of-page-action :allow)
      (setf selected-objects-pane inst)
      pane)))

;; action pane
(defun make-iapropos-frame-action-pane ()
  (clim:vertically nil
    (clim:make-pane 'clim:push-button
                    :activate-callback #'(lambda (gadget)
                                           (declare (ignore gadget))
                                           (com-quit))
                    :label "return")
    (clim:make-pane 'clim:push-button
                    :activate-callback #'(lambda (gadget)
                                           (declare (ignore gadget))
                                           (iapropos-frame-reset-options clim:*application-frame*))
                    :label "reset")
    (clim:make-pane 'clim:push-button
                    :activate-callback #'(lambda (gadget)
                                           (declare (ignore gadget))
                                           (com-edit-copy-to-clipboard))
                    :label "copy")))

;;;
;;;
;;;

(clim:define-presentation-type matched-object ())

(clim:define-presentation-type matched-object-package ())

(clim:define-presentation-type source-location ())

(clim:define-presentation-type inspect-object ())

(clim:define-presentation-method clim:present (loc (type source-location) stream
                                                   (view clim:textual-view)
                                                   &key acceptably for-context-type)
  (declare (ignore acceptably for-context-type))
  (princ (format nil "~A:~A" (car loc) (cdr loc)) stream))

(clim:define-presentation-method clim:present (object (type inspect-object) stream
                                                      (view clim:textual-view)
                                                      &key acceptably for-context-type)
  (declare (ignore acceptably for-context-type))
  (princ object stream))

(clim:define-presentation-method clim:present (object (type matched-object-package) stream
                                                      (view clim:textual-view)
                                                      &key acceptably for-context-type)
  (declare (ignore acceptably for-context-type))
  (princ (package-name object) stream))

;;;
;;;
;;;

(defmacro with-fixed-vertical-scroll-bar (pane &body body)
  (let ((vscrollbar (gensym "VSCROLLBAR"))
        (vsb-value (gensym "VSB-VALUE")))
    `(let* ((,vscrollbar (slot-value (clim:sheet-parent
                                      (clim:sheet-parent
                                       ,pane))
                                     'climi::vscrollbar))
            (,vsb-value (slot-value ,vscrollbar 'climi::value)))
       ,@body
       (progn
         (climi::drag-callback ,vscrollbar nil nil ,vsb-value)
         (setf (clim:gadget-value ,vscrollbar) ,vsb-value)))))

;;;
;;; commands
;;;

;; command table
(clim:define-command-table iapropos-command-table)
(clim:define-command-table iapropos-edit-command-table)

;; commands
(defvar *return-values* nil)

(clim:define-command (com-quit
                      :command-table iapropos-command-table
                      :menu t
                      :name "quit"
                      :keystroke (#\q :meta))
    ()
  (with-slots (selected-values single-selection-p)
      clim:*application-frame*
    (setf *return-values*
          (if single-selection-p
              (car selected-values)
              (remove-duplicates selected-values))))
  (clim:frame-exit clim:*application-frame*))

(clim:define-command (com-edit-copy-to-clipboard
                      :command-table iapropos-edit-command-table
                      :menu t
                      :name "copy"
                      :keystroke (#\C :control))
    ()
  (with-slots (selected-values single-selection-p)
      clim:*application-frame*
    (let ((selection
           (if single-selection-p
               (car selected-values)
               (remove-duplicates selected-values))))
      (clim-extensions:publish-selection
       (clim:frame-top-level-sheet clim:*application-frame*)
       :clipboard
       (format nil "~S" selection)
       :string))))

(clim:define-command (com-edit-select-all
                      :command-table iapropos-edit-command-table
                      :menu t
                      :name "select all"
                      :keystroke (#\a :meta :control))
    ()
  (with-slots (selected-values single-selection-p iapropos) clim:*application-frame*
    (unless single-selection-p
      (setf selected-values (iapropos-matched-objects iapropos))))
  (iapropos-frame-refresh-selected-objects-pane clim:*application-frame*)
  (iapropos-frame-refresh-metched-objects-pane clim:*application-frame*))

(clim:define-command (com-edit-select-none
                      :menu t
                      :command-table iapropos-edit-command-table
                      :name "select none"
                      :keystroke (#\n :meta :control))
    ()
  (with-slots (selected-values) clim:*application-frame*
    (setf selected-values nil))
  (iapropos-frame-refresh-selected-objects-pane clim:*application-frame*)
  (iapropos-frame-refresh-metched-objects-pane clim:*application-frame*))

(clim:define-command (com-edit-select-object
                      :menu nil
                      :command-table iapropos-edit-command-table
                      :name "select object")
    ((object 'matched-object :gesture :select))
  (let ((frame clim:*application-frame*))
    (with-slots (selected-values single-selection-p matched-objects-pane) frame
      (if single-selection-p
          (setf selected-values (list object))
          (if (member object selected-values)
              (setf selected-values (remove object selected-values))
              (setf selected-values (remove-duplicates (push object selected-values)))))
      (with-fixed-vertical-scroll-bar matched-objects-pane
        (iapropos-frame-refresh-metched-objects-pane frame))
      (iapropos-frame-refresh-selected-objects-pane frame))))

(defparameter *apropos-edit-fn* #'(lambda (file loc line-no)
                                    (format *debug-io* "edit file ~A (~A/~A)~%" file loc line-no)))
#|
#'(lambda (file loc nline)
      (climacs:edit-file file)
      (unless (climacs::find-climacs-frame)
        (sleep 1))
      (clim:execute-frame-command (climacs::find-climacs-frame)
                            (list 'drei-commands::com-goto-position loc))))
|#

(clim:define-command (com-edit-file
                      :menu nil
                      :command-table iapropos-edit-command-table
                      :name "edit file")
    ((loc 'source-location :gesture :select))
  (when (probe-file (car loc))
    (let ((nline 1))
      (with-open-file (f (car loc) :direction :input
                         ;;:element-type '(char))
                         )
        (loop for i from 0 to (cdr loc)
              for c = (read-char f nil nil)
              do (when (eql c #\Newline)
                   (incf nline))))
      (when *apropos-edit-fn*
        (funcall *apropos-edit-fn* (car loc) (cdr loc) nline)))))

(defparameter *apropos-inspect-fn* #'(lambda (object)
                                       (format *debug-io* "inspect object ~A~%" object)))

#|
  #'(lambda (object)
      (clouseau:inspect object)))
|#

(clim:define-command (com-edit-inspect-object
                      :menu nil
                      :command-table iapropos-edit-command-table
                      :name "inspect object")
    ((object 'inspect-object :gesture :select))
  (when *apropos-inspect-fn*
    (funcall *apropos-inspect-fn* object)))

(clim:define-command (com-edit-move-focus
                      :menu nil
                      :command-table iapropos-edit-command-table
                      :name "move focus"
                      :keystroke (#\Tab))
    ()
  (let ((cur (clim:port-keyboard-input-focus (clim:port clim:*application-frame*))))
    (with-slots (option-panes iapropos) clim:*application-frame*
      (let ((all nil))
        (loop for (opt pane) on option-panes by #'cddr
              do
                 (when (eql (search-option-type (iapropos-option iapropos opt)) :regex)
                   (setf all (push (car (clim:sheet-children pane)) all))))
        (let ((pos (position cur all)))
          (setf (clim:port-keyboard-input-focus (clim:port clim:*application-frame*))
                (if (and pos (< (1+ pos) (length all)))
                    (elt all (1+ pos))
                    (car all))))))))

(clim:define-command (com-edit-select-object-package
                      :command-table iapropos-edit-command-table
                      :name "Select Object Package")
    ((package 'matched-object-package :gesture :select))
  (setf (clim:gadget-value
         (clim:find-pane-named clim:*application-frame* 'object-package-regex-text-field))
        (format nil "^~A$" (package-name package))))

;;;
;;;
;;;

(defun run-iapropos-application-frame (application-frame &key (new-process nil)
                                         (width 790)
                                         (height 550)
                                         port
                                         frame-manager
                                         (pretty-name "iapropos")
                                         (process-name "iapropos-frame"))
  (let* ((fm (or frame-manager (clim:find-frame-manager :port (or port (clim:find-port)))))
         (frame (clim:make-application-frame application-frame
                                             :pretty-name pretty-name
                                             :frame-manager fm
                                             :width width
                                             :height height)))
    (iapropos-application-initialize frame)
    (flet ((run ()
             (let ((*return-values* nil))
               (unwind-protect (clim:run-frame-top-level frame)
                 (clim:disown-frame fm frame))
               *return-values*)))
      (if new-process
          (values
           (bt:make-thread #'run :name process-name)
           frame)
          (run)))))
